;;##########################################################################
;; systmob4
;; Copyright (c) 1991-98 by Forrest W. Young
;; Continuation of code for ViSta system object.  
;; Has code for Redraw Supervisor and Color Picker
;;##########################################################################


;=======================
;SPREADPLOT OPTIONS
;======================

(defmeth vista-system-object-proto :spreadplot-options ()
  (let ((choices (choose-subset-dialog "SpreadPlot Options"
            (list "Seamless SpreadPlots" "Maximize SpreadPlots")
            :initial (list *seamless-spreadplots* *maximize-spreadplots*)))
        (setf *seamless-spreadplots* nil)
        (setf *maximize-spreadplots* nil)
        )
    (when choices
          (dotimes (i 2)
                   (when (member i (first choices))
                         (case i
                           (0 (setf *seamless-spreadplots* t))
                           (1 (setf *maximize-spreadplots* t))))))))
          
;=======================
; REDRAW SUPERVISOR
;=======================


(defmeth vista-system-object-proto :ready-to-redraw (w)
  (let* ((ra (send self :redraw-active))
         (prl (send self :postponed-redraw-list))
         (returned-value t)
         )
    (when ra
          (send self :postponed-redraw-list
               (remove-duplicates 
                (combine
                 (add-element-to-list (send self
:postponed-redraw-list) w)
                 *workmap*)))
          (setf returned-value nil))
    (when (and (equal w *workmap*) (send self :postponed-redraw-list))
          (send self :postponed-redraw-list 
                (remove-duplicates
                 (combine (send self :postponed-redraw-list)
*workmap*))))
    (send self :redraw-active t)
    returned-value))
			
(defmeth vista-system-object-proto :finished-redraw (w)
  (let* ((prl (send self :postponed-redraw-list))
         (next-w nil)
         )
    (send self :redraw-active nil)
    (when prl
          (setf next-w (first prl))
          (send self :postponed-redraw-list (rest prl))
          (send next-w :redraw))))



;(defmeth vista-system-object-proto :ready-to-redraw (w)
;  t)

;(defmeth vista-system-object-proto :finished-redraw (w)
;  )

;=======================
; COLOR PICKER
;=======================

(defun change-colors ()
  (let ((wb nil)
        (result (send *vista* :change-color-dialog)))
    (when result
          (let* (( wb (copy-list *workmap-background*))
                ( tb (copy-list *toolbar-background*))
                ( dic (copy-list *data-icon-cap-color*)) 
                ( mic (copy-list *model-icon-cap-color*)) 
                ( tic (copy-list *tool-icon-color*))
                ( gic (copy-list *guide-icon-color*))
                ( bonc (copy-list *button-on-color*)) 
                ( bofc (copy-list *button-off-color*)))
            (send *vista* :color-values-list 
                  (list wb tb dic mic tic gic bonc bofc)))
          (when *update-pref-files*
                (save-desktop-settings)
                (send *vista* :save-prefload)))))

(defmeth vista-system-object-proto :change-color-dialog ()
"Args: none
Dialog to change color of a ViSta object."
  (when (= *color-mode* 0)
        (when *guidemap* 
              (send *guidemap* :use-color t)
              (send *guidemap* :back-color 'workmap-background)
              (send *guidemap* :redraw)
              )
        (send graph-proto :use-color t)
        (send *vista* :background-color t)
        (send *workmap* :use-color t)
        (send *workmap* :back-color 'workmap-background)
        (send *workmap* :redraw)
        (setf *color-mode* 1)
        (when *current-spreadplot*
              (when (send *current-spreadplot* :has-slot 'plot-matrix)
                    (mapcar #'(lambda (plot) (send plot :redraw))
                            (combine (row-list 
                                      (send *current-spreadplot* 
                                            :plot-matrix))))))
        )  
  (let* (
         (dialog-title (send text-item-proto :new (format nil "CHANGE COLORS:~%Follow the 3 Steps Given Below")))
         (mode-text (send text-item-proto :new "1: Choose Color Type"))
         (color-mode (send choice-item-proto :new 
                     (list "Basic 64" "216 Web Colors" "256 Colors" "Many Colors")
                           :value (1- *color-mode*)))
         (choice-text (send text-item-proto :new "2: Select Object"))
         (choice (send choice-item-proto :new
                    '("WorkMap Background" "Tool and Button Bars"
                      "Data Icon Caps" "Model Icon Caps" "Analysis Icons"
                      "GuideMap Icons" 
                      "Plot Buttons - ON" "Plot Buttons - OFF") :value 0
                       ))
         (object-list       (list *workmap* *toolbox* dob-icon-proto 
                                  mob-icon-proto tool-icon-proto
                                  guide-icon-proto
                                  graph-proto graph-proto))
         (object-title-list (list "WorkMap" "Tool and Button Bars" "Data Icon Caps" 
                                  "Model Icon Caps" "Analysis Icon" "GuideMap Icon" 
                                  "Plot Buttons - ON" "Plot Buttons - OFF"))
         (color-symbol-list (list 'workmap-background 'toolbar-background
                   'data-icon-cap-color 'model-icon-cap-color 'tool-icon-color
                                  'guide-icon-color
                                  'button-on-color 'button-off-color))
         (color-values-list 
          (list (copy-list *workmap-background*)
                (copy-list *toolbar-background*)
                (copy-list *data-icon-cap-color*) 
                (copy-list *model-icon-cap-color*) 
                (copy-list *tool-icon-color*) 
                (copy-list *guide-icon-color*)
                (copy-list *button-on-color*) 
                (copy-list *button-off-color*)))
         (object (first object-list))
         (title (first object-title-list))
         (color-symbol (first color-symbol-list))
         (color-values (first color-values-list))
         (r nil) (g nil) (b nil)
         (num (case *color-mode* (1 3) (2 5) (3 7) (4 100)))
         (slider-text (send text-item-proto :new "3: Use Color Sliders"))
         (rtext  (send text-item-proto :new "RED Strength:"))
         (rvalue (send text-item-proto :new "0.0" :text-length 1))
         (rslide (send scroll-item-proto :new :max-value num
                       :page-increment (if (< num 100) 1 5)))
         (gtext  (send text-item-proto :new "GREEN Strength:"))
         (gvalue (send text-item-proto :new "0.0" :text-length 1))
         (gslide (send scroll-item-proto :new :max-value num
                       :page-increment (if (< num 100) 1 5)))
         (btext  (send text-item-proto :new "BLUE Strength:"))
         (bvalue (send text-item-proto :new "0.0" :text-length 1))
         (bslide (send scroll-item-proto :new :max-value num
                       :page-increment (if (< num 100) 1 5)))
         (color-off (send modal-button-proto :new "Color Off" :action 
            #'(lambda () (send *vista* :turn-color-off)
                t)))
         (cancel (send modal-button-proto :new "Cancel"
                     :action #'(lambda ()
                 (let ((cvl (send *vista* :color-values-list)))
                   (setf *workmap-background* (select cvl 0))
                   (setf *toolbar-background* (select cvl 1))
                   (setf *data-icon-cap-color* (select cvl 2))
                   (setf *model-icon-cap-color* (select cvl 3))
                   (setf *tool-icon-color* (select cvl 4))
                   (setf *guide-icon-color* (select cvl 5))
                   (setf *button-on-color* (select cvl 6))
                   (setf *button-off-color* (select cvl 7))
                   (apply #'make-color 'workmap-background 
                          *workmap-background*)
                   (apply #'make-color 'toolbar-background 
                          *toolbar-background*)
                   (apply #'make-color 'data-icon-cap-color 
                          *data-icon-cap-color*)
                   (apply #'make-color 'model-icon-cap-color 
                          *model-icon-cap-color*)
                   (apply #'make-color 'tool-icon-color 
                          *tool-icon-color*)
                   (apply #'make-color 'guide-icon-color 
                          *guide-icon-color*)
                   (apply #'make-color 'button-on-color 
                          *button-on-color*)
                   (apply #'make-color 'button-off-color 
                          *button-off-color*)
                   (send *workmap* :redraw))
                                 )))
         (OK (send modal-button-proto :new "OK"
                     :action #'(lambda () 
                   (send *workmap* :redraw)
                                 t)))
         (layout (send modal-dialog-proto :new
                       (list dialog-title
                             (list 
                              (list mode-text 
                                    color-mode 
                                    ;color-off 
                                    cancel OK)
                              (list choice-text choice)
                              (list
                               slider-text
                               (list rtext rvalue) rslide
                               (list gtext gvalue) gslide
                               (list btext bvalue) bslide)))
                             :default-button OK))
         )
    (defmeth choice :do-action ()
      (let ((value (send self :value))
            (rval nil)
            (gval nil)
            (bval nil)
            )
        (setf object (select object-list value))
        (setf title (select object-title-list value))
        (setf color-symbol (select color-symbol-list value))
        (setf color-values (select color-values-list value))
        (setf rval (floor (* num (first  color-values))))
        (setf gval (floor (* num (second color-values))))
        (setf bval (floor (* num (third  color-values))))
        (send rvalue :text  (format nil "~s" rval))
        (send gvalue :text  (format nil "~s" gval))
        (send bvalue :text  (format nil "~s" bval))
        (send rslide :value rval)
        (send gslide :value gval)
        (send bslide :value bval)))

    (defmeth color-mode :do-action ()
      (let ((prev-color-mode *color-mode*)
            (new-color-mode (1+ (send self :value))))
        (setf *color-mode* new-color-mode)
        (setf num (case *color-mode* (1 3) (2 5) (3 7) (4 100)))
        (send rslide :change-color-mode prev-color-mode new-color-mode)
        (send gslide :change-color-mode prev-color-mode new-color-mode)
        (send bslide :change-color-mode prev-color-mode new-color-mode)
        ))

    (defmeth scroll-item-proto :change-color-mode (prev-color-mode new-color-mode)
      (let* ((prev-max (send self :max-value))
             (prev-value (send self :value))
             (prev-prop (/ prev-value prev-max))
             )
        (send self :max-value num)
        (send self :value (round (* (send self :max-value) prev-prop)))
        (send self :slot-value 'page-increment (if (> num 10) 5 1))
        (send self :do-action)
        ))

    (defmeth rslide :scroll-action ()
      (send *vista* :bar-action rslide rvalue 0))

    (defmeth rslide :do-action ()
      (send *vista* :bar-action rslide rvalue 0))

    (defmeth gslide :scroll-action ()
      (send *vista* :bar-action gslide gvalue 1))

    (defmeth gslide :do-action ()
      (send *vista* :bar-action gslide gvalue 1))

    (defmeth bslide :scroll-action ()
      (send *vista* :bar-action bslide bvalue 2))

    (defmeth bslide :do-action ()
      (send *vista* :bar-action bslide bvalue 2))

    (defmeth *vista* :bar-action (slider slider-text color-channel)
      (let ((object-number (send choice :value))
            (x (send slider :value)))
        (send slider-text :text (format nil "~s" x))
        (send slider :value x)
        (change-object-color 
         (/ x num) object color-symbol color-values color-channel 
         object-number)))
   
   ; (send object :start-buffering)
    (send choice :do-action)
    (when (> 0 *color-mode* 4)
          (let ((values (round (* num *workmap-background*))))
            (send rslide :value (select values 0))
            (send gslide :value (select values 1))
            (send bslide :value (select values 2))
            (send *vista* :bar-action rslide rvalue 0)
            (send *vista* :bar-action gslide gvalue 1)
            (send *vista* :bar-action bslide bvalue 2)))
   ; (send object :buffer-to-screen)
    (send layout :modal-dialog)

    ))

(defun change-object-color 
      (x object color-symbol color-values color-channel-number object-number)
      (when (not (send object :has-slot 'rgb))
            (send object :add-slot 'rgb color-values))
      (let* ((rgb (send object :slot-value 'rgb))
             )
        (setf (select rgb color-channel-number) x)
        (send object :slot-value 'rgb rgb)
        (setf color-values rgb)
        (apply #'make-color color-symbol rgb)
        (case object-number
          (0 (setf *workmap-background* color-values))
          (1 (setf *toolbar-background* color-values))
          (2 (setf *data-icon-cap-color* color-values))
          (3 (setf *model-icon-cap-color* color-values))
          (4 (setf *tool-icon-color* color-values))
          (5 (setf *guide-icon-color* color-values))
          (6 (setf *button-on-color* color-values))
          (7 (setf *button-off-color* color-values)))
        (when (< object-number 5)(send *workmap* :redraw))
        (when (and *guidemap* (or (= object-number 1 ) (= object-number 5)))
              (send *guidemap* :redraw))
        (when (and *current-spreadplot* (or (= object-number 1) 
                                            (> object-number 5)))
              (when (send *current-spreadplot* :has-slot 'plot-matrix)
                    (mapcar #'(lambda (plot) (send plot :redraw))
                            (combine (row-list 
                                      (send *current-spreadplot* 
                                            :plot-matrix))))))
        ))

(defmeth vista-system-object-proto :turn-color-off ()
  (send *vista* :background-color nil)
  (send *workmap* :use-color nil)
  (send *workmap* :back-color 'white)
  (send *workmap* :redraw)
  (when *guidemap*
        (send *guidemap* :use-color nil)
        (send *guidemap* :back-color 'white)
        (send *guidemap* :redraw))
  (setf *color-mode* 0)
  (send graph-proto :use-color nil)
  (when *current-spreadplot*
        (when (send *current-spreadplot* :has-slot 
                    'plot-matrix)
              (mapcar #'(lambda (plot) (send plot :redraw))
                      (combine (row-list 
                                (send *current-spreadplot* 
                                      :plot-matrix))))))
  )